'---- programa sam1imageconv1b.amos baseado em msx1imageconv1c - rgb - cluster
'---- iniciado em 22oct00

dim rfromat[16],gfromat[16],bfromat[16]
dim realpal[16],grpltlv[16],celcnt[16]
dim opaletr[16],opaletg[16],opaletb[16]
dim npaletr[16],npaletg[16],npaletb[16]
dim xpnt[8]

'start:
'screen 0,0,0: color 0,7 :cls
' print:print" samcoupe mode2 (8x1) image converter (bmp 16c - 8/4bit) - 0111251643"
' print:print" drag a file icon here over this dos-console window and press enter"
' print:print" this converter will generate a binary msx1 screen and a 8bit bmp file"
' print" with the same name from its source":print: print" ";
'input f1$
' on error goto start

f1t=len(f1$):f3$=left$(f1$,f1t-4)+".bm8"
 open f1$ for random as #1 len=1:f1b$="a":field #1,1 as fb1$
 open f3$ for random as #3 len=1:f3b$="a":field #3,1 as fb3$

'---- cabecalho do formato bmp-8bit
'dtabmp8hd:
'  data 66,77,124,192,0,0,0,0,0,0,122,0,0,0,40,0
'  data 0,0,0,1,0,0,192,0,0,0,1,0,8,0,0,0
'  data 0,0,0,0,0,0,16,10,0,0,16,10,0,0,17,0
'  data 0,0,17,0,0,0
'  data 0,0,0,0,0,0,0,0,34,204,34,0,34,136,34,0
'  data 238,34,34,0,238,102,68,0,34,34,170,0,238,204,68,0
'  data 34,34,238,0,102,102,238,0,136,204,204,0,34,204,204,0
'  data 34,136,34,0,170,68,204,0,170,170,170,0,238,238,238,0
'  data 255,255,255,0
'restore dtabmp8hd
'  for i=1 to 122:read grd:seek #3,i:lset fb3$=chr$(grd):put #3:next i


get #1,19:xsiz0=asc(fb1$):get #1,20:xsiz1=asc(fb1$)
 xmax=xsiz0+(xsiz1*256):xmaxo=int(xmax/8):xmaxoo=xmaxo*8:xsm0=(xmaxoo and 255)
 seek #3,19:lset fb3$=chr$(xsm0):put #3:seek #3,20:lset fb3$=chr$(xsiz1):put #3
get #1,23:ysiz0=asc(fb1$):get #1,24:ysiz1=asc(fb1$)
 ymax=ysiz0+(ysiz1*256):ymaxo=int(ymax/8):ymaxoo=ymaxo*8:ysm0=(ymaxoo and 255)
 seek #3,23:lset fb3$=chr$(ysm0):put #3:seek #3,24:lset fb3$=chr$(ysiz1):put #3

'---- bmp source format
   ympos= 28+1:get #1, ympos:bitdepth=asc(fb1$)
   ympos= 11+1:get #1, ympos:imstart=(asc(fb1$))*256
   ympos= 10+1:get #1, ympos:imstart=imstart+asc(fb1$)
    palsz=int((imstart-54)/4)
orderedpalette:
  if palsz>16 then palsz=16
for i=0 to palsz-1: ympos= 54+1+(i*4)
    get #1, ympos+1: j=int(asc(fb1$)/32):grky=j mod 2
      opaletg(i)=j:j2=int((j*255)/7)
      seek #3,ympos+1:lset fb3$=chr$(j2):put #3
    get #1, ympos  : j=(int(asc(fb1$)/64)*2)+jrky
      opaletr(i)=j:j2=int((j*255)/7)
      seek #3,ympos  :lset fb3$=chr$(j2):put #3
    get #1, ympos+2: j=(int(asc(fb1$)/64)*2)+jrky
      opaletb(i)=j:j2=int((j*255)/7)
      seek #3,ympos+2:lset fb3$=chr$(j2):put #3
 next

for i=palsz-1 to 15
    opaletr(i)=opaletr(palsz-1):opaletg(i)=opaletg(palsz-1)
    opaletb(i)=opaletb(palsz-1)
 next i
for i=0 to 15
    npaletr(i)=((opaletr(i))*255)/7:npaletg(i)=((opaletg(i))*255)/7
    npaletb(i)=((opaletb(i))*255)/7
    grpltlv(i)=(npaletg(i)*59)+(npaletr(i)*30)+(npaletb(i)*11)
 next i

'----transfer palette converting for msx2 limits / define palette grayscale 
for y=0 to 15
  gpal=opaletg(y):bpal=opaletb(y):rpal=opaletr(y)
  grpltlv(y)=((((bpal*11)+(rpal*30)+(gpal*59))*255)/700)
  rfromat(y)=(rpal*255)/7:gfromat(y)=(gpal*255)/7:bfromat(y)=(bpal*255)/7
next y

'----correcao da paleta 
for i=0 to 15:realpal(i)=i:next i
for j=0 to 15:for i=0 to 14
  if grpltlv(i)>grpltlv(i+1) then
    swap grpltlv(i),grpltlv(i+1)
    swap rfromat(i),rfromat(i+1):swap gfromat(i),gfromat(i+1)
    swap bfromat(i),bfromat(i+1):swap realpal(i),realpal(i+1)
  end if 
next i:next j

'----main loop 
for y=0 to ymax-1
'for y1=0 to ymaxo-1
     locate 24,2:print using"###%";(y*100)/ymax;
  for x1=0 to xmaxo-1
'    for y2=0 to 7

'----atribute reading and mounting
       for i=0 to 15:celcnt(i)=0:next i
      for x2=0 to 7
          'y=(y1*8)+y2 : 
          xp=(x1*8)+x2: iy=(ymax-1)-y 
        xh=int(xp/2)
          if bitdepth=8 then
            ympos= imstart+1+xp+(yi*xmax): get #1, ympos
            xpnt(x2)=(asc(fb1$)) mod 16
           end if
          if bitdepth=4 then
            ympos= imstart+1+xh+(yi*(int(xmax/2))): get #1, ympos
            u1=asc(fb1$): u2=x2 mod 2
              if u2=0 then
                u3=240 : u4=16
              end if
              if u2=1 then
               u3=15:u4=1
              end if
            xpnt(x2)= int((u1 and u3)/u4)
          end if
            u=xpnt(x2)   
        celcnt(u)=celcnt(u)+1000+(rnd(99))
      next x2

        ikattr=0 : paattr=0:ikcnt=0 : pacnt=0
      for i=0 to 15
	if ikcnt<celcnt(i) then
          ikcnt=celcnt(i):ikattr=i
        end if 
      next i

        celcnt(ikattr)=0
      for i=0 to 15
	if pacnt<celcnt(i) then
          pacnt=celcnt(i):paattr=i
        end if 
      next i

        if ikattr<paattr then swap ikattr,paattr
      lumd=(grpltlv(ikattr)+grpltlv(paattr))/2


        iko=int(ikattr/8):pao=int(paattr/8)
      if iko<>pao then
           diptt=9999:ikok=(iko*8)
         for i=0+ikok to 7+ikok
             disr=abs(npaletr(i)-npaletr(paattr))
             disg=abs(npaletg(i)-npaletg(paattr))
             disb=abs(npaletb(i)-npaletb(paattr))
	     dist=sqr((disr^2)+(disg^2)+(disb^2))
               if dist<diptt and i<>paattrs then
                 diptt=dist
                 paattrn=i
               end if
	 next i
           paattr=paattrn
      end if


'---- reading original 16 colour image as grayscale for screen 2 
        pkvar=0
      for x2=0 to 7
        'y=y2+(y1*8):
        x=x2+(x1*8):yi=(ymaxoo-1)-y
            u=xpnt(x2): ik=paattr
	  if grpltlv(u)>lumd then
            ik=ikattr
          end if 
            seek #3,123+(yi*xmaxoo)+x:lset fb3$=chr$(ik):put #3
      next x2
'    next y2
  next x1
'next y1
next y

   close #1:close #3
goto start




